home *** CD-ROM | disk | FTP | other *** search
/ Hardcore Visual Basic 5.0 (2nd Edition) / Hardcore Visual Basic 5.0 - Second Edition (1997)(Microsoft Press).iso / Code / comctl.cls < prev    next >
Text File  |  1997-06-14  |  4KB  |  114 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4. END
  5. Attribute VB_Name = "GCommonControl"
  6. Attribute VB_GlobalNameSpace = True
  7. Attribute VB_Creatable = True
  8. Attribute VB_PredeclaredId = False
  9. Attribute VB_Exposed = True
  10. Option Explicit
  11.  
  12. Public Enum EErrorCommonControl
  13.     eeBaseCommonControl = 13440     ' CommonControl
  14. End Enum
  15.  
  16. ' Helpers for common control functions and image lists
  17.  
  18. Function INDEXTOOVERLAYMASK(i As Long) As Long
  19.     INDEXTOOVERLAYMASK = i * 256
  20. End Function
  21.  
  22. ' ImageList_ReplaceIcon(himl, -1, hicon)
  23. Function ImageList_AddIcon(ByVal himl As Long, ByVal hIcon As Long) As Long
  24.     ImageList_AddIcon = ImageList_ReplaceIcon(himl, -1, hIcon)
  25. End Function
  26.  
  27. ' ImageList_Remove(himl, -1)
  28. Function ImageList_RemoveAll(ByVal himl As Long) As Long
  29.     ImageList_RemoveAll = ImageList_Remove(himl, -1)
  30. End Function
  31.  
  32. ' ImageList_GetIcon(himl, i, 0)
  33. Function ImageList_ExtractIcon(ByVal himl As Long, ByVal i As Long) As Long
  34.     ImageList_ExtractIcon = ImageList_GetIcon(himl, i, 0)
  35. End Function
  36.  
  37. ' ImageList_LoadImage(hi, lpbmp, cx, cGrow, crMask, IMAGE_BITMAP, 0)
  38. Function ImageList_LoadBitmap(ByVal hi As Long, ByVal lpbmp As String, _
  39.     ByVal cx As Long, ByVal cGrow As Long, ByVal crMask As Long, _
  40.     ByVal uType As Long, ByVal uFlags As Long) As Long
  41.     ImageList_LoadBitmap = ImageList_LoadImage(hi, lpbmp, cx, cGrow, _
  42.                                                crMask, IMAGE_BITMAP, 0)
  43. End Function
  44.  
  45. #If fComponent Then
  46. Sub DrawImage(imlst As Object, vIndex As Variant, ByVal hDC As Long, _
  47.               ByVal x As Long, ByVal y As Long, _
  48.               Optional ByVal afDraw As EILD = ILD_TRANSPARENT)
  49. #Else
  50. Sub DrawImage(imlst As Control, vIndex As Variant, ByVal hDC As Long, _
  51.               ByVal x As Long, ByVal y As Long, _
  52.               Optional ByVal afDraw As EILD = ILD_TRANSPARENT)
  53. #End If
  54.     ImageList_Draw imlst.hImageList, _
  55.                    imlst.ListImages(vIndex).Index - 1, hDC, _
  56.                    x / Screen.TwipsPerPixelX, _
  57.                    y / Screen.TwipsPerPixelY, afDraw
  58. End Sub
  59.  
  60.  
  61. ' System image lists
  62.  
  63. Function GetSysImageList(cCount As Long, _
  64.                          Optional ByVal fLargeIcon As Boolean = True) As Long
  65.     Dim shfi As SHFILEINFO
  66.     Dim hSysIm As Long, hIcon As Long, af As Long
  67.     af = SHGFI_SYSICONINDEX Or _
  68.          IIf(fLargeIcon, SHGFI_LARGEICON, SHGFI_SMALLICON)
  69.     hSysIm = SHGetFileInfo(Left$(CurDir$, 3), 0, shfi, Len(shfi), af)
  70.     cCount = ImageList_GetImageCount(hSysIm)
  71.     GetSysImageList = hSysIm
  72. End Function
  73.  
  74. Function GetSysIcon(ByVal hSysIm As Long, ByVal i As Integer, _
  75.                     Optional ByVal xWidth As Long, _
  76.                     Optional ByVal yHeight As Long) As Picture
  77.     Set GetSysIcon = Nothing
  78.     Dim f As Boolean, cx As Long, cy As Long
  79.     Dim iminf As IMAGEINFO
  80.     f = ImageList_GetImageInfo(hSysIm, i, iminf)
  81.     If Not f Then Exit Function
  82.     f = ImageList_GetIconSize(hSysIm, cx, cy)
  83.     If Not f Then Exit Function
  84.     ' These just go to temporary variables if missing
  85.     xWidth = cx
  86.     yHeight = cx
  87.     ' Check for bitmap
  88.     If iminf.hbmMask = hNull Then Exit Function
  89.     ' Get icon handle and convert to picture
  90.     Set GetSysIcon = MPicTool.IconToPicture(ImageList_GetIcon(hSysIm, i, ILD_NORMAL))
  91.     
  92. End Function
  93.  
  94. #If fComponent = 0 Then
  95. Private Sub ErrRaise(e As Long)
  96.     Dim sText As String, sSource As String
  97.     If e > 1000 Then
  98.         sSource = App.ExeName & ".CommonControl"
  99.         Select Case e
  100.         Case eeBaseCommonControl
  101.             BugAssert True
  102.        ' Case ee...
  103.        '     Add additional errors
  104.         End Select
  105.         Err.Raise COMError(e), sSource, sText
  106.     Else
  107.         ' Raise standard Visual Basic error
  108.         sSource = App.ExeName & ".VBError"
  109.         Err.Raise e, sSource
  110.     End If
  111. End Sub
  112. #End If
  113.  
  114.